home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / struct < prev    next >
Text File  |  1993-09-08  |  4KB  |  137 lines
  1. ;;; struct.scm: defmacros which implement RECORDS from the book:
  2. ;;; "Essentials of Programming Languages" by Daniel P. Friedman,
  3. ;;;   M. Wand and C.T. Haynes.
  4. ;;; Copyright 1992 Jeff Alexander, Shinnder Lee, and Lewis Patterson
  5.  
  6. ;;; jaffer@ai.mit.edu, Feb 1993 ported to SLIB.
  7.  
  8. (require 'common-list-functions)
  9.  
  10. (defmacro define-record args
  11.   (check-define-record-syntax args
  12.     (lambda (name make-name name? field-accessors)
  13.       (letrec
  14.     ((make-fields
  15.        (lambda (field-accessors i)
  16.          (if (null? field-accessors)
  17.            '()
  18.            (cons
  19.          `(define ,(car field-accessors)
  20.             (lambda (obj)
  21.               (if (,name? obj)
  22.             (vector-ref obj ,i)
  23.             (error ',(car field-accessors)
  24.               ": bad record" obj))))
  25.          (make-fields (cdr field-accessors) (+ i 1)))))))
  26.     `(begin
  27.        ,@(make-fields field-accessors 1)
  28.        (define ,name?
  29.          (lambda (obj)
  30.            (and (vector? obj)
  31.          (= (vector-length obj) ,(+ 1 (length field-accessors)))
  32.          (eq? (vector-ref obj 0) ',name))))
  33.        (define ,make-name
  34.          (lambda ,field-accessors
  35.            (vector ',name ,@field-accessors))))))))
  36.  
  37. (defmacro variant-case args
  38.   (check-variant-case-syntax args
  39.     (lambda (exp clauses)
  40.       (let ((var (gentemp)))
  41.     (let
  42.       ((make-clause
  43.          (lambda (clause)
  44.            (if (eq? (car clause) 'else)
  45.          `(#t ,@(cdr clause))
  46.          `((,(car clause) ,var)
  47.            (let ,(map (lambda (field)
  48.                 `(,(car field) (,(cdr field) ,var)))
  49.                (cadr clause))
  50.              ,@(cddr clause)))))))
  51.       `(let ((,var ,exp))
  52.          (cond ,@(map make-clause clauses))))))))
  53.  
  54. ;;; syntax checkers
  55.  
  56. ;;; name make-name name? field-accessors
  57.  
  58. (define check-define-record-syntax
  59.   (lambda (x k)
  60.       (cond
  61.     ((and (list? x)
  62.        (= (length x) 2)
  63.        (symbol? (car x))
  64.        (list? (cadr x))
  65.        (comlist:every symbol? (cadr x))
  66.        (not (struct:duplicate-fields? (cadr x))))
  67.      (let ((name (symbol->string (car x))))
  68.        (let ((make-name (string->symbol
  69.                   (string-append (symbol->string 'make-) name)))
  70.          (name? (string->symbol (string-append name "?")))
  71.          (field-accessors
  72.            (map
  73.              (lambda (field)
  74.                (string->symbol
  75.              (string-append name "->" (symbol->string field))))
  76.              (cadr x))))
  77.          (k (car x) make-name name? field-accessors))))
  78.     (else (error "define-record: invalid syntax" x)))))
  79.        
  80. (define check-variant-case-syntax
  81.   (let
  82.     ((make-clause
  83.        (lambda (clause)
  84.      (if (eq? (car clause) 'else) 
  85.        clause
  86.        (let ((name (symbol->string (car clause))))
  87.          (let ((name? (string->symbol (string-append name "?")))
  88.            (fields
  89.              (map
  90.                (lambda (field)
  91.              (cons field
  92.                (string->symbol
  93.                  (string-append name "->"
  94.                    (symbol->string field)))))
  95.                (cadr clause))))
  96.            (cons name? (cons fields (cddr clause)))))))))
  97.     (lambda (args k)
  98.       (if (and (list? args)
  99.         (<= 2 (length args))
  100.         (struct:clauses? (cdr args)))
  101.     (k (car args) (map make-clause (cdr args)))
  102.     (error "variant-case: invalid syntax" args)))))
  103.  
  104. (define struct:duplicate-fields?
  105.   (lambda (fields)
  106.     (cond
  107.       ((null? fields) #f)
  108.       ((memq (car fields) (cdr fields)) #t)
  109.       (else (struct:duplicate-fields? (cdr fields))))))
  110.  
  111. (define struct:clauses?
  112.   (let
  113.     ((clause?
  114.        (lambda (clause)
  115.      (and (list? clause)
  116.           (not (null? clause))
  117.           (cond
  118.         ((eq? (car clause) 'else)
  119.          (not (null? (cdr clause))))
  120.         (else (and (symbol? (car clause))
  121.                (not (null? (cdr clause)))
  122.                (list? (cadr clause))
  123.                (comlist:every symbol? (cadr clause))
  124.                (not (struct:duplicate-fields? (cadr clause)))
  125.                (not (null? (cddr clause))))))))))
  126.     (letrec
  127.       ((struct:duplicate-tags?
  128.      (lambda (tags)
  129.        (cond
  130.          ((null? tags) #f)
  131.          ((eq? (car tags) 'else) (not (null? (cdr tags))))
  132.          ((memq (car tags) (cdr tags)) #t)
  133.          (else (struct:duplicate-tags? (cdr tags)))))))
  134.       (lambda (clauses)
  135.     (and (comlist:every clause? clauses)
  136.          (not (struct:duplicate-tags? (map car clauses))))))))
  137.